unit UScriptClass;

interface
uses Classes, SysUtils, controls, Generics.Collections, dialogs, UMonoIntf, UMono, Rtti;

type
  TStrings_helper = class
  public
    class function get_Item(aSelf: TStrings; aIndex: integer): string; static;
    class procedure set_Item(aSelf: TStrings; aIndex: integer; s: string); static;
    class function get_Names(aSelf: TStrings; aIndex: integer): string; static;
    class function get_Values(aSelf: TStrings; aName: string): string; static;
    class procedure set_Values(aSelf: TStrings; aName: string; s: string); static;
  end;

  TMonoDelegateCallEvent = reference to function(m: PMonoMethod; o: PMonoObject): PMonoObject;

  TAbsEvent_helper = class(TObject)
  protected
    FEventList: TDictionary<string,Cardinal>;
    FOriginalEvent: TMethod;
    function GetMonoObj(gcHandle: cardinal): PMonoObject;
    procedure CallEventList(callback: TMonoDelegateCallEvent);
  public
    constructor Create(aOriginalEvent: TMethod); virtual;
    function GetOriginalEvent: TMethod;
    function EventCount: integer;
    function GetMethodEvent: TMethod; virtual; abstract;
    procedure addEvent(aID: string; aDelegate: PMonoObject); virtual;
    procedure removeEvent(aID: string); virtual;
    destructor Destroy; override;
  end;
  TAbsEvent_helperclass = class of TAbsEvent_helper;


  TMonoEventComp = class(TComponent)
  private
    FList: TDictionary<string,TAbsEvent_helper>;
  protected
    class var EventClassList: TDictionary<string,TAbsEvent_helperclass>;
    function GetMonoEventID(aDelegate: PMonoObject): string;
  public
    function add_Delegate(aEventName: string; aSignature: string; aDelegate: PMonoObject; var aResult: TValue): boolean; virtual;
    function remove_delegate(aEventName: string; aDelegate: PMonoObject; var aResult: TValue): boolean; virtual;
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    class function FindEventHlpClass(aName: string): TAbsEvent_helperclass;
    class procedure RegisterEventHlpClass(AName: string; aClass: TAbsEvent_helperclass);
    class constructor Create;
    class destructor Destroy;
  end;

type

  TNofityEvent_helper = class(TAbsEvent_helper)
    function GetMethodEvent: TMethod; override;
    procedure DoEvent(Sender: TObject);
  end;

  TKeyPressEvent_helper = class(TAbsEvent_helper)
    function GetMethodEvent: TMethod; override;
    procedure DoEvent(Sender: TObject; var aKey: Char);
  end;

function ScriptHelper(aClass: TClass): TClass;
procedure RegisterScriptHelper(aClass, aHlpClass: TClass);



implementation
uses StrUtils;

var
  LsHlpClass: TDictionary<TClass,TClass> = nil;

procedure RegisterScriptHelper(aClass, aHlpClass: TClass);
begin
  if LsHlpClass = nil then
    LsHlpClass := TDictionary<TClass,TClass>.Create();
  LsHlpClass.Add(aClass, aHlpClass);
end;

function ScriptHelper(aClass: TClass): TClass;
var
  lClass: TClass;
begin
  result := nil;
  if LsHlpClass = nil then
    exit;
  lClass := aClass;
  while (lClass <> nil) and (not LsHlpClass.TryGetValue(lClass, result)) do
    lClass := lClass.ClassParent;
end;



{ TStrings_helper }

class function TStrings_helper.get_Item(aSelf: TStrings;
  aIndex: integer): string;
begin
  result := aSelf[aIndex];
end;

class function TStrings_helper.get_Names(aSelf: TStrings;
  aIndex: integer): string;
begin
  result := aSelf.Names[aIndex];
end;

class function TStrings_helper.get_Values(aSelf: TStrings;
  aName: string): string;
begin
  Result := aSelf.Values[aName];
end;

class procedure TStrings_helper.set_Item(aSelf: TStrings; aIndex: integer;
  s: string);
begin
  aSelf[aIndex] := s;
end;

class procedure TStrings_helper.set_Values(aSelf: TStrings; aName, s: string);
begin
  aSelf.Values[aName] := s;
end;

{ TNofityEvent_helper }


procedure TNofityEvent_helper.DoEvent(Sender: TObject);
begin
  CallEventList(
    function (m: PMonoMethod; o: PMonoObject): PMonoObject
     begin
       result := MonoJit.CallMonoMethod(m, o, [sender]);
     end
  );
  if FOriginalEvent.Code <> nil then
    TNotifyEvent(FOriginalEvent)(Sender);
end;

function TNofityEvent_helper.GetMethodEvent: TMethod;
begin
  TNotifyEvent(result) := DoEvent;
end;

{ TMonoEventComp }

function TMonoEventComp.add_Delegate(aEventName: string; aSignature: string;
  aDelegate: PMonoObject; var aResult: TValue): boolean;
var
  hcls: TAbsEvent_helperclass;
  lID: string;
  eventobj: TAbsEvent_helper;
  methodp: ^TMethod;
begin
  result := false;
  lId := GetMonoEventID(aDelegate);
  if not FList.TryGetValue(aEventName, eventObj) then
  begin
    hcls := FindEventHlpClass(aSignature);
    if hcls = nil then
      hcls := FindEventHlpClass(ExcludeNameSpace(aSignature));
    if hcls <> nil then
    begin
      result := true;
      MethodP := aResult.GetReferenceToRawData;
      eventobj := hcls.Create(methodp^);
      MethodP^ := eventobj.GetMethodEvent;
      FList.Add(aEventName, eventobj);
    end
    else
      exit;
  end;
  eventobj.addEvent(lID, aDelegate);
end;

procedure TMonoEventComp.AfterConstruction;
begin
  inherited;
  FList := TDictionary<string,TAbsEvent_helper>.Create;
end;

procedure TMonoEventComp.BeforeDestruction;
var
  item: TPair<string,TAbsEvent_helper>;
begin
  inherited;
  for item in FList do
  begin
    item.Value.Free;
  end;

  FList.Free;
end;

class constructor TMonoEventComp.Create;
begin
  EventClassList := TDictionary<string,TAbsEvent_helperclass>.Create();
end;

class destructor TMonoEventComp.Destroy;
begin
  EventClassList.Free;
end;

class function TMonoEventComp.FindEventHlpClass(
  aName: string): TAbsEvent_helperclass;
begin
  if not EventClassList.TryGetValue(UpperCase(aName), result) then
  begin
    result := nil;
  end;
end;

function TMonoEventComp.GetMonoEventID(aDelegate: PMonoObject): string;
var
  o, o2: PMonoObject;
begin
  o := MonoJit.CallMonoMethod(MonoJit.FindMonoMethod(mono_object_get_class(aDelegate), 'get_Target', '', false), aDelegate, []);
  if o <> nil then
  begin
    o2 := MonoJit.CallMonoMethod(MonoJit.FindMonoMethod(mono_object_get_class(o), 'ToString', '', false), o, []);
    result := TMonoConvert.MonoStrToString(PMonoString(o2));
  end
  else
    result := 'Anonymous';
  o := MonoJit.CallMonoMethod(MonoJit.FindMonoMethod(mono_object_get_class(aDelegate), 'get_Method', '', false), aDelegate, []);
  o2 := MonoJit.CallMonoMethod(MonoJit.FindMonoMethod(mono_object_get_class(o), 'ToString', '', false), o, []);
  result := result + '->'+ TMonoConvert.MonoStrToString(PMonoString(o2));
end;

class procedure TMonoEventComp.RegisterEventHlpClass(AName: string;
  aClass: TAbsEvent_helperclass);
begin
  EventClassList.Add(UpperCase(aName), aClass);
end;

function TMonoEventComp.remove_delegate(aEventName: string; aDelegate: PMonoObject; var aResult: TValue): boolean;
var
  eventobj: TAbsEvent_helper;
  lID: string;
  MethodP: ^TMethod;
begin
  result := false;
  lID := GetMonoEventID(aDelegate);
  if FList.TryGetValue(aEventName, eventObj) then
  begin
    MethodP := aResult.GetReferenceToRawData;
    eventobj.removeEvent(lID);
    if eventobj.EventCount = 0 then
    begin
      MethodP^ := eventobj.GetOriginalEvent;
      result := true;
      eventobj.Free;
      FList.Remove(aEventName);
    end;
  end;
end;

{ TAbsEvent_helper }

procedure TAbsEvent_helper.addEvent(aID: string; aDelegate: PMonoObject);
begin
  FEventList.Add(aID, mono_gchandle_new(aDelegate, true));
end;

procedure TAbsEvent_helper.CallEventList(callback: TMonoDelegateCallEvent);
var
  m: PMonoMethod;
  o: PMonoObject;
  item: TPair<string,Cardinal>;
begin
  for item in FEventList do
  begin
    o := GetMonoObj(item.Value);
    m := mono_get_delegate_invoke(mono_object_get_class(o));

    if Assigned(callback) then
      callback(m, o);
  end;
end;

constructor TAbsEvent_helper.Create(aOriginalEvent: TMethod);
begin
  inherited Create;
  FEventList := TDictionary<string,Cardinal>.Create();
  FOriginalEvent := aOriginalEvent;
end;

destructor TAbsEvent_helper.Destroy;
var
  pair: TPair<string,cardinal>;
begin
  if Assigned(MonoJit) and (MonoJit.Domain <> nil)  then
    for pair in FEventList do
    begin
      if pair.Value <> 0 then
        mono_gchandle_free(pair.Value);
    end;
  FEventList.Free;
  inherited;
end;

function TAbsEvent_helper.EventCount: integer;
begin
  result := FEventList.Count;
end;

function TAbsEvent_helper.GetMonoObj(gcHandle: cardinal): PMonoObject;
begin
  result := mono_gchandle_get_target(gcHandle);
end;

function TAbsEvent_helper.GetOriginalEvent: TMethod;
begin
  result := FOriginalEvent;
end;

procedure TAbsEvent_helper.removeEvent(aID: string);
var
  lgcHandle: cardinal;
begin
  if FEventList.TryGetValue(aID, lgcHandle) then
  begin
    if lgcHandle <> 0 then
      mono_gchandle_free(lgcHandle);
    FEventList.Remove(aID);
  end;
end;

{ TKeyPressEvent_helper }

procedure TKeyPressEvent_helper.DoEvent(Sender: TObject; var aKey: Char);
var
  lKey: char;
begin
  lKey := aKey;
  CallEventList(
    function (m: PMonoMethod; o: PMonoObject): PMonoObject
     begin
       result := MonoJit.CallMonoMethod(m, o, [sender, @lKey]);
     end
  );
  aKey := lKey;
  if FOriginalEvent.Code <> nil then
    TKeyPressEvent(FOriginalEvent)(Sender, aKey);
end;

function TKeyPressEvent_helper.GetMethodEvent: TMethod;
begin
  TKeyPressEvent(result) := DoEvent;
end;

initialization
  RegisterScriptHelper(TStrings, TStrings_helper);
  TMonoEventComp.RegisterEventHlpClass('TNotifyEvent', TNofityEvent_helper);
  TMonoEventComp.RegisterEventHlpClass('TKeyPressEvent', TKeyPressEvent_helper);
finalization
  LsHlpClass.Free;
end.
